;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;file-looker.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;
;;  this file creates a sample stand-alone application.
;;  the application lets you look at directories and files.
;;
;;  The current functionality is very basic, but it could easily be extended.
;;
;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  create a new class of dialogs
;;

(defobject *files-dialog* *dialog*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  define an exist procedure
;;

(defobfun (exist *files-dialog*) (args)
  (have 'directory (or (getf args :directory) (default-directory)))
  (usual-exist (init-list-default args
                                  :window-title directory
                                  :window-font '("monaco" 9)
                                  :window-show nil
                                  :window-type :document-with-grow))
  (add-dialog-items
   (oneof *static-text-dialog-item*
          :dialog-item-text "Type Creator Name"
          :dialog-item-position #@(0 4))
   (have 'file-table (oneof *file-list-item* 
                           :directory directory
                           :dialog-item-position #@(0 23)
                           :dialog-item-size  #@(133 85))))
  (set-window-size #@(200 180))
  (window-show))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  define set-window-size to resize the table in the window
;;

(defobfun (set-window-size *files-dialog*) (h &optional v &aux pt)
  (declare (object-variable table-item text-item window-grow-rect))
  (setq pt (make-point h v)
        h (point-h pt)
        v (point-v pt))
  (ask file-table
    (set-dialog-item-size h (- v 23))
    (set-cell-size (- h 15) 11))
  (usual-set-window-size pt))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  define a new class of tables for displaying items in the window
;;

(defobject *file-list-item* *table-dialog-item*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  the exist procedure creates a list of entries from a directory
;;  the list holds the contents of the directory
;;

(defobfun (exist *file-list-item*) (args &aux files)
  (have 'directory (getf args :directory))
  (have 'my-files
        (do-files-in-directory (f directory (nreverse files))
          (push (cons (let ((full-name (concatenate 'string directory f)))
                        (if (directoryp f)
                          (format nil "Folder       ~a" f)
                          (format nil "~a  ~a   ~a"
                                  (file-type full-name)
                                  (file-creator full-name) f)))
                      f)
                files)))
  (usual-exist (init-list-default args
                                  :table-dimensions (make-point 1 (length my-files))
                                  :table-vscrollp t
                                  :table-hscrollp t
                                  :cell-size #@(133 11))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  cell-contents returns a string showing the filename and other information
;;  this is what is displayed in the table
;;

(defobfun (cell-contents *file-list-item*) (h &optional v)
  (car (elt my-files (point-v (make-point h v)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  the action is run when you click a cell
;;
;;  if you click a folder, it opens a new window showing the contents of the folder
;;
;;  if you click a file, it doesn't do anything, but it could easily be
;;  extended to do something.
;;

(defobfun (dialog-item-action *file-list-item*) ()
  (if (double-click-p)
    (let ((file (cdr (elt my-files (point-v (car (selected-cells)))))))
      (if (directoryp file)
        (oneof *files-dialog*
               :directory (concatenate 'string directory file)
               :window-position (add-points (ask my-dialog (window-position))
                                            #@(20 20)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  this is the about-box put up by the application
;;

(defun about-file-looker ()
  (let ((dlg (oneof *dialog*
                    :window-type :single-edge-box
                    :window-size #@(200 100)
                    :window-position #@(20 40)
                    :window-show nil)))
    (ask dlg
      (add-dialog-items
       (oneof *static-text-dialog-item*
              :dialog-item-position #@(4 4)
              :dialog-item-size #@(300 65)
              :dialog-item-text "File Looker:
A simple application
created using Pearl Lisp
by Coral Software")
       (oneof *button-dialog-item*
              :dialog-item-text "Okay"
              :dialog-item-action #'(lambda ()
                                      (return-from-modal-dialog nil)))))
    (modal-dialog dlg)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  the startup procedure displays windows for each mounted device, and
;;  then falls into a loop that doesn't do anything.
;;
;;  Once things are initialized, all the action happens in response to events
;;

(defun startup ()
  (catch :abort
    (catch :error
      ;create some windows
      (do* ((pos #@(4 40) (add-points pos #@(20 20)))
            (devices (directory "*:") (cdr devices)))
           ((null devices))
        (oneof *files-dialog* 
               :directory (car devices)
               :window-position pos))))
  (%set-toplevel #'(lambda ()
                     (loop
                       (event-dispatch)
                       (unless (%set-toplevel) (return nil))))))

#|
;once the rest of this is evaluated, the following code will install
;the new menubar and create the application

(let ((about-item (ask *apple-menu* (car (menu-items))))
      (*warn-if-redefine-kernel* nil))
  (ask about-item
    (set-menu-item-title "About File Looker...")
    (setf (symbol-function 'menu-item-action) #'about-file-looker)
    (setf (symbol-function 'menu-item-update) #'(lambda ()))))

(setq *new-file-menu* (oneof *menu* :menu-title "File"))
(ask *new-file-menu* (add-menu-items (oneof *menu-item*
                                            :menu-item-title "Quit"
                                            :command-key #\Q
                                            :menu-item-action 
                                            #'(lambda () 
                                                (%set-toplevel nil)))))

(dolist (m (menubar))
  (ask m (menu-dispose)))

(ask *new-file-menu* (menu-install))

(save-application (choose-new-file-dialog :pathname "file-looker")
                  :toplevel-function #'startup)
|#